Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE14/TLIST/LISTDEMO.PAS

Pascal/Delphi Source File | 1996-07-25 | 16.4 KB | 536 lines

{This program demonstrates the use of lists to hold a database table.
  The lists index the table by three methods. For extra speed the indexes
  have binary searches that are FAR more complicated than simple loops
  but which work exponentially faster}

{ Program by J.Morgan [e-mail]

  It is freeware and that means don't blame me if it falls over!
  It is also just a demonstration and not supposed to be bullet-proof, or
  even particularly "tightly" coded}

{ TO RUN: Needs an Alias entered in the BDE "CategoriesDB"
       Nothing special about it -- it should just be of type
       Interbase and point to the ctgrs.gdb file }

unit ListDemo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Mask, Grids, Outline, DB, DBTables;

type
    {this class matches the fields in the Database table}
  TCategory = class
    CategoryID,
    OutLinePosition,
    OutLineParent : Longint;
    Description : string[40];
  end;

  TCatIndex = (ciDescription, ciOutlinePosition, ciCategoryID);

    {This class holds three indexes to a list of records. It also gives
     a few extra functions to make life a little easier. AddRecord
     inserts a new record into the lists in the correct position.
     Search xxx finds the record with the entered variable. First and
     next make looping through the lists easy (and possible)}
  TCategoryContainer = class
  private
    ByDescription,
    ByOutlinePosition,
    ByCategoryID : TList;

    fCatIndex : TCatIndex;
    fCurrentIndex : LongInt;
  public
    procedure AddRecord( ACategory : TCategory );
    function SearchDescription( s : string) : TCategory;
    function SearchOutlinePosition( i : LongInt) : TCategory;
    function SearchCategoryID( i : LongInt) : TCategory;
    function First( CatIndex : TCatIndex ) : TCategory;
    function Next : TCategory;

    constructor Create;
    destructor Destroy; override;
  end;

  TfrmCategories = class(TForm)
    Outline1: TOutline;
    Label1: TLabel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    ListBox1: TListBox;
    Label2: TLabel;
    Label3: TLabel;
    lblTime: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    edtDescription: TEdit;
    edtIndex: TMaskEdit;
    edtID: TMaskEdit;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    Label7: TLabel;
    Edit1: TEdit;
    Query1: TQuery;
    Database1: TDatabase;
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
  private
    { Private declarations }
    CatContainer : TCategoryContainer;
    StartTime : TDateTime;

    procedure StartOp;
    procedure EndOp;
    procedure ShowResult( ACategory : TCategory );
  public
    { Public declarations }
  end;

var
  frmCategories: TfrmCategories;

implementation

{$R *.DFM}

constructor TCategoryContainer.Create;
begin
  inherited Create;

  ByDescription:=TList.Create;
  ByOutLinePosition:=TList.Create;
  ByCategoryID:=TList.Create;
end;

destructor TCategoryContainer.Destroy;
var
  i: LongInt;
begin
  for i:=0 to ByCategoryID.Count-1 do
    TCategory(ByDescription[i]).Free;

  ByDescription.Free;
  ByOutLinePosition.Free;
  ByCategoryID.Free;

  inherited Destroy;
end;

procedure TCategoryContainer.AddRecord( ACategory : TCategory );
var
  i, delta, CurrInt : LongInt;
  CurrStr : string;

         {The most complicated things in this program are the binary search
         functions. This one recursively iterates through the list-so-far,
         looking for where the new record should be inserted. Once it finds
         a position where the description is <= to the new record's description,
         and the following positon has a description >= then it returns that
         position's index in the list. We could have simply looped from start
         to finish looking for the right position to insert but this method will
         be far quicker on big lists.
         Because we have three indexes we will create one of these functions for
         each index type}
  function DescAppendPos( index : LongInt ) : LongInt;
  var
    Prev, Next : string;
    isPrev, isNext : boolean;
  begin
         {Get the description at and after the position we are looking at}
    isPrev:=index>=0;
    isNext:=index+1<ByDescription.Count;
    if isPrev then Prev:=TCategory(ByDescription[index]).Description;
    if isNext then Next:=TCategory(ByDescription[index+1]).Description;

         {Set result is CurrStr is between Prev and Next}
    if ((isPrev and (CurrStr>=Prev) and (not isNext or (CurrStr<=Next)))) or
       ((not isPrev and (not isNext or (CurrStr<=Next)))) then Result:=index
    else {we are not at the right position so move a half distance}
    begin
      delta:=delta div 2; {create a half distance}
      if delta=0 then delta:=1;

      if Prev<=CurrStr then Result:=DescAppendPos( index + Delta )
      else               Result:=DescAppendPos( index - Delta )
    end;
  end;

  function IDAppendPos( index : LongInt ) : LongInt; {See DescAppendPos comments}
  var
    Prev, Next : LongInt;
    isPrev, isNext : boolean;
  begin
    isPrev:=index>=0;
    isNext:=index+1<ByCategoryID.Count;
    if isPrev then Prev:=TCategory(ByCategoryID[index]).CategoryID;
    if isNext then Next:=TCategory(ByCategoryID[index+1]).CategoryID;
    if ((isPrev and (CurrInt>=Prev) and (not isNext or (CurrInt<=Next)))) or
       ((not isPrev and (not isNext or (CurrInt<=Next)))) then Result:=index
    else
    begin
      delta:=delta div 2;
      if delta=0 then delta:=1;
      if Prev<=CurrInt then Result:=IDAppendPos( index + Delta )
      else               Result:=IDAppendPos( index - Delta )
    end;
  end;

  function PositionAppendPos( index : LongInt ) : LongInt;  {See DescAppendPos comments}
  var
    Prev, Next : LongInt;
    isPrev, isNext : boolean;
  begin
    isPrev:=index>=0;
    isNext:=index+1<ByOutlinePosition.Count;
    if isPrev then Prev:=TCategory(ByOutlinePosition[index]).OutlinePosition;
    if isNext then Next:=TCategory(ByOutlinePosition[index+1]).OutlinePosition;
    if ((isPrev and (CurrInt>=Prev) and (not isNext or (CurrInt<=Next)))) or
       ((not isPrev and (not isNext or (CurrInt<=Next)))) then Result:=index
    else
    begin
      delta:=delta div 2;
      if delta=0 then delta:=1;
      if Prev<=CurrInt then Result:=PositionAppendPos( index + Delta )
      else               Result:=PositionAppendPos( index - Delta )
    end;
  end;

begin {Add Record}
  {------------------------------------------------------}
      {need to add the record into the Description list...}
  if ByDescription.Count=0 then i:=0
  else begin
      {First we need the position on the list where to insert the record}
    delta:=(ByDescription.Count div 2);
    CurrStr:=ACategory.Description;
      {Then we will call a binary search to find where to put this record}
    i:=DescAppendPos(delta)+1;
  end;
      {And finally we insert the record in the description list}
  ByDescription.Insert(i, ACategory);
  {------------------------------------------------------}
      {now the same for the CategoryID list...}
  if ByCategoryID.Count=0 then i:=0
  else begin
    delta:=(ByCategoryID.Count div 2);
    CurrInt:=ACategory.CategoryID;
    i:=IDAppendPos(delta)+1;
  end;
  ByCategoryID.Insert(i, ACategory);
  {------------------------------------------------------}
      {and the same for the OutlinePosition list...}
  if ByOutLinePosition.Count=0 then i:=0
  else begin
    delta:=(ByOutLinePosition.Count div 2);
    CurrInt:=ACategory.OutlinePosition;
    i:=PositionAppendPos(delta)+1;
  end;
  ByOutlinePosition.Insert(i, ACategory);
end;

function TCategoryContainer.SearchDescription( s : string) : TCategory;
var
  delta : LongInt;
          {Binary search the list for the "s" string}
  function DescPos( index : LongInt ) : TCategory;
  var
    ACategory: TCategory;
  begin
    if (index<0) or (index>=ByDescription.Count) then Result:=nil
    else begin
         {Get the description at and after the position we are looking at}
      ACategory:=TCategory(ByDescription[index]);
      if ACategory.Description=s then Result:=ACategory
      else begin
        delta:=delta div 2; {create a half distance}
        if delta=0 then delta:=1;
          {decide whether to carry on looking and if so in which direction}
        if (ACategory.Description<s) and (index+1<ByDescription.Count) and
           (TCategory(ByDescription[index+1]).Description<=s)
               then Result:=DescPos( index + Delta )
        else if (ACategory.Description>s) and (index-1>=0) and
           (TCategory(ByDescription[index-1]).Description>=s)
               then Result:=DescPos( index - Delta )
        else Result:=nil
      end;
    end;
  end;

begin {Find Record}
  if ByDescription.Count=0 then Result:=nil
  else begin
      {Start from the middle of the list}
    delta:=(ByDescription.Count div 2);
      {Then we will call a binary search to find where the description is}
    Result:=DescPos(delta);
  end;
end;

function TCategoryContainer.SearchOutlinePosition( i : LongInt) : TCategory;
var
  delta : LongInt;
          {Binary search the list for the "i" Position}
  function PositionPos( index : LongInt ) : TCategory;
  var
    ACategory: TCategory;
  begin
    if (index<0) or (index>=ByOutlinePosition.Count) then Result:=nil
    else begin
         {Get the OutlinePosition at and after the position we are looking at}
      ACategory:=TCategory(ByOutlinePosition[index]);
      if ACategory.OutlinePosition=i then Result:=ACategory
      else begin
        delta:=delta div 2; {create a half distance}
        if delta=0 then delta:=1;
          {decide whether to carry on looking and if so in which direction}
        if (ACategory.OutlinePosition<i) and (index+1<ByOutlinePosition.Count) and
           (TCategory(ByOutlinePosition[index+1]).OutlinePosition<=i)
               then Result:=PositionPos( index + Delta )
        else if (ACategory.OutlinePosition>i) and (index-1>=0) and
           (TCategory(ByOutlinePosition[index-1]).OutlinePosition>=i)
               then Result:=PositionPos( index - Delta )
        else Result:=nil
      end;
    end;
  end;

begin {Find Record (by Position)}
  if ByOutlinePosition.Count=0 then Result:=nil
  else begin
      {Start from the middle of the list}
    delta:=(ByOutlinePosition.Count div 2);
      {Then we will call a binary search to find where the OutlinePosition is}
    Result:=PositionPos(delta);
  end;
end;

function TCategoryContainer.SearchCategoryID( i : LongInt) : TCategory;
var
  delta : LongInt;
          {Binary search the list for the "i" Category}
  function CategoryPos( index : LongInt ) : TCategory;
  var
    ACategory: TCategory;
  begin
    if (index<0) or (index>=ByCategoryID.Count) then Result:=nil
    else begin
         {Get the CategoryID at and after the Category we are looking at}
      ACategory:=TCategory(ByCategoryID[index]);
      if ACategory.CategoryID=i then Result:=ACategory
      else begin
        delta:=delta div 2; {create a half distance}
        if delta=0 then delta:=1;
          {decide whether to carry on looking and if so in which direction}
        if (ACategory.CategoryID<i) and (index+1<ByCategoryID.Count) and
           (TCategory(ByCategoryID[index+1]).CategoryID<=i)
               then Result:=CategoryPos( index + Delta )
        else if (ACategory.CategoryID>i) and (index-1>=0) and
           (TCategory(ByCategoryID[index-1]).CategoryID>=i)
               then Result:=CategoryPos( index - Delta )
        else Result:=nil
      end;
    end;
  end;

begin {Find Record (by Category)}
  if ByCategoryID.Count=0 then Result:=nil
  else begin
      {Start from the middle of the list}
    delta:=(ByCategoryID.Count div 2);
      {Then we will call a binary search to find where the CategoryID is}
    Result:=CategoryPos(delta);
  end;
end;

function TCategoryContainer.First( CatIndex : TCatIndex ) : TCategory;
begin
  fCatIndex:=CatIndex;
  fCurrentIndex:=-1;
  Result:=Next;
end;

function TCategoryContainer.Next : TCategory;
begin
  Inc(fCurrentIndex);
  case fCatIndex of
    ciDescription :
      if fCurrentIndex>=ByDescription.Count then Result:=nil
      else Result:=TCategory(ByDescription[fCurrentIndex]);
    ciOutlinePosition :
      if fCurrentIndex>=ByOutlinePosition.Count then Result:=nil
      else Result:=TCategory(ByOutlinePosition[fCurrentIndex]);
    ciCategoryID :
      if fCurrentIndex>=ByCategoryID.Count then Result:=nil
      else Result:=TCategory(ByCategoryID[fCurrentIndex]);
  end;
end;

{--------------------------TfrmCategories----------------------------}
procedure TfrmCategories.Button1Click(Sender: TObject);
begin
  OutLine1.Clear;
  StartOp;
  with Query1 do
  begin
    sql.clear;
    sql.add('SELECT DESCRIPTION, OUTLINEPARENT FROM CATEGORIES');
    sql.add('ORDER BY OUTLINEPOSITION');
    Open;
    while not eof do
    begin
      Outline1.AddChild(Fields[1].AsInteger, Fields[0].AsString);
      Next;
    end;
    Close;
  end;
  EndOp;
end;

procedure TfrmCategories.Button3Click(Sender: TObject);
begin
  ListBox1.Clear;
  StartOp;
  with Query1 do
  begin
    sql.clear;
    sql.add('SELECT DESCRIPTION FROM CATEGORIES');
    sql.add('ORDER BY DESCRIPTION');
    Open;
    while not eof do
    begin
      ListBox1.items.Add(Fields[0].AsString);
      Next;
    end;
    Close;
  end;
  EndOp;
end;

procedure TfrmCategories.FormCreate(Sender: TObject);
var
  ACategory : TCategory;
begin
     {create the container}
  CatContainer:=TCategoryContainer.Create;

     {then fill it up with the records currently in the table}
  with Query1 do
  begin
    sql.clear;
    sql.add('SELECT CATEGORYID, OUTLINEPOSITION, OUTLINEPARENT, DESCRIPTION FROM CATEGORIES');
    Open;
    while not eof do
    begin
      ACategory:=TCategory.Create;
      with ACategory do
      begin
        CategoryID:=Fields[0].AsInteger;
        OutlinePosition:=Fields[1].AsInteger;
        OutlineParent:=Fields[2].AsInteger;
        Description:=Fields[3].AsString;
      end;
      CatContainer.AddRecord(ACategory);
      Next;
    end;

    Close;
  end;
end;

procedure TfrmCategories.FormDestroy(Sender: TObject);
begin
  CatContainer.Free;
end;

procedure TfrmCategories.Button4Click(Sender: TObject);
var
  ACategory : TCategory;
begin
  ListBox1.Clear;
  StartOp;
  with CatContainer do
  begin
    ACategory:=First(ciDescription);
    while ACategory<>nil do
    begin
      ListBox1.Items.Add(ACategory.Description);
      ACategory:=Next;
    end;
  end;
  EndOp;
end;

procedure TfrmCategories.Button2Click(Sender: TObject);
var
  ACategory : TCategory;

begin
  OutLine1.Clear;
  StartOp;
  with CatContainer do
  begin
    ACategory:=First(ciOutlinePosition);
    while ACategory<>nil do
    begin
      Outline1.AddChild(ACategory.OutlineParent, ACategory.Description);
      ACategory:=Next;
    end;
  end;
  EndOp;
end;

procedure TfrmCategories.StartOp;
begin
  StartTime:=time;
end;

procedure TfrmCategories.EndOp;
var
  Hour, Min, Sec, MSec : Word;

begin
  DecodeTime(time-startTime, Hour, Min, Sec, MSec);
  lblTime.caption:=format('%2.2d:%2.2d.%d', [Min, Sec, MSec]);
end;

procedure TfrmCategories.Button5Click(Sender: TObject);
begin
  ShowResult( CatContainer.SearchDescription(edtDescription.Text) );
end;

procedure TfrmCategories.ShowResult(ACategory : TCategory);
begin
  if ACategory=nil then Edit1.Text:='Category Not Found'
  else Edit1.Text:=ACategory.Description+', '+IntToStr(Acategory.CategoryID);
end;

procedure TfrmCategories.Button6Click(Sender: TObject);
begin
  if edtIndex.text<>'' then
    ShowResult( CatContainer.SearchOutlinePosition(StrToInt(edtIndex.Text)) );
end;

procedure TfrmCategories.Button7Click(Sender: TObject);
begin
  if edtID.text<>'' then
    ShowResult( CatContainer.SearchCategoryID(StrToInt(edtID.Text)) );
end;

end.